home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / tests / remote.tcl < prev    next >
Encoding:
Text File  |  1997-08-15  |  4.1 KB  |  162 lines  |  [TEXT/ALFA]
  1. # This file contains Tcl code to implement a remote server that can be
  2. # used during testing of Tcl socket code. This server is used by some
  3. # of the tests in socket.test.
  4. #
  5. # Source this file in the remote server you are using to test Tcl against.
  6. #
  7. # Copyright (c) 1995-1996 Sun Microsystems, Inc.
  8. #
  9. # See the file "license.terms" for information on usage and redistribution
  10. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11. #
  12. # @(#) remote.tcl 1.5 96/04/17 08:21:19"
  13.  
  14. # Initialize message delimitor
  15.  
  16. # Initialize command array
  17. catch {unset command}
  18. set command(0) ""
  19. set callerSocket ""
  20.  
  21. # Detect whether we should print out connection messages etc.
  22. if {![info exists VERBOSE]} {
  23.     set VERBOSE 0
  24. }
  25.  
  26. proc __doCommands__ {l s} {
  27.     global callerSocket VERBOSE
  28.  
  29.     if {$VERBOSE} {
  30.     puts "--- Server executing the following for socket $s:"
  31.     puts $l
  32.     puts "---"
  33.     }
  34.     set callerSocket $s
  35.     if {[catch {uplevel #0 $l} msg]} {
  36.     list error $msg
  37.     } else {
  38.     list success $msg
  39.     }
  40. }
  41.  
  42. proc __readAndExecute__ {s} {
  43.     global command VERBOSE
  44.  
  45.     set l [gets $s]
  46.     if {[string compare $l "--Marker--Marker--Marker--"] == 0} {
  47.     if {[info exists command($s)]} {
  48.         puts $s [list error incomplete_command]
  49.     }
  50.     puts $s "--Marker--Marker--Marker--"
  51.     return
  52.     }
  53.     if {[string compare $l ""] == 0} {
  54.     if {[eof $s]} {
  55.         if {$VERBOSE} {
  56.         puts "Server closing $s, eof from client"
  57.         }
  58.         close $s
  59.     }
  60.     return
  61.     }
  62.     append command($s) $l "\n"
  63.     if {[info complete $command($s)]} {
  64.     set cmds $command($s)
  65.     unset command($s)
  66.     puts $s [__doCommands__ $cmds $s]
  67.     }
  68.     if {[eof $s]} {
  69.     if {$VERBOSE} {
  70.         puts "Server closing $s, eof from client"
  71.     }
  72.     close $s
  73.     }
  74. }
  75.  
  76. proc __accept__ {s a p} {
  77.     global VERBOSE
  78.  
  79.     if {$VERBOSE} {
  80.     puts "Server accepts new connection from $a:$p on $s"
  81.     }
  82.     fileevent $s readable [list __readAndExecute__ $s]
  83.     fconfigure $s -buffering line -translation crlf
  84. }
  85.  
  86. set serverIsSilent 0
  87. for {set i 0} {$i < $argc} {incr i} {
  88.     if {[string compare -serverIsSilent [lindex $argv $i]] == 0} {
  89.     set serverIsSilent 1
  90.     break
  91.     }
  92. }
  93. if {![info exists serverPort]} {
  94.     if {[info exists env(serverPort)]} {
  95.     set serverPort $env(serverPort)
  96.     }
  97. }
  98. if {![info exists serverPort]} {
  99.     for {set i 0} {$i < $argc} {incr i} {
  100.     if {[string compare -port [lindex $argv $i]] == 0} {
  101.         if {$i < [expr $argc - 1]} {
  102.         set serverPort [lindex $argv [expr $i + 1]]
  103.         }
  104.         break
  105.     }
  106.     }
  107. }
  108. if {![info exists serverPort]} {
  109.     set serverPort 2048
  110. }
  111.  
  112. if {![info exists serverAddress]} {
  113.     if {[info exists env(serverAddress)]} {
  114.     set serverAddress $env(serverAddress)
  115.     }
  116. }
  117. if {![info exists serverAddress]} {
  118.     for {set i 0} {$i < $argc} {incr i} {
  119.     if {[string compare -address [lindex $argv $i]] == 0} {
  120.         if {$i < [expr $argc - 1]} {
  121.         set serverAddress [lindex $argv [expr $i + 1]]
  122.         }
  123.         break
  124.     }
  125.     }
  126. }
  127. if {![info exists serverAddress]} {
  128.     set serverAddress 0.0.0.0
  129. }
  130.  
  131. if {$serverIsSilent == 0} {
  132.     set l "Remote server listening on port $serverPort, IP $serverAddress."
  133.     puts ""
  134.     puts $l
  135.     for {set c [string length $l]} {$c > 0} {incr c -1} {puts -nonewline "-"}
  136.     puts ""
  137.     puts ""
  138.     puts "You have set the Tcl variables serverAddress to $serverAddress and"
  139.     puts "serverPort to $serverPort. You can set these with the -address and"
  140.     puts "-port command line options, or as environment variables in your"
  141.     puts "shell."
  142.     puts ""
  143.     puts "NOTE: The tests will not work properly if serverAddress is set to"
  144.     puts "\"localhost\" or 127.0.0.1."
  145.     puts ""
  146.     puts "When you invoke tcltest to run the tests, set the variables"
  147.     puts "remoteServerPort to $serverPort and remoteServerIP to"
  148.     puts "[info hostname]. You can set these as environment variables"
  149.     puts "from the shell. The tests will not work properly if you set"
  150.     puts "remoteServerIP to \"localhost\" or 127.0.0.1."
  151.     puts ""
  152.     puts -nonewline "Type Ctrl-C to terminate--> "
  153.     flush stdout
  154. }
  155.  
  156. if {[catch {set serverSocket \
  157.     [socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} {
  158.     puts "Server on $serverAddress:$serverPort cannot start: $msg"
  159. } else {
  160.     vwait __server_wait_variable__
  161. }
  162.